home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / t3_1 / nexttsrc.lha / nexttsources / nexttsystem / tea.el < prev   
Lisp/Scheme  |  1993-07-23  |  15KB  |  421 lines
  1. ;;; -*-Emacs-Lisp-*- Tea under emacs stuff.
  2. ;; Copyright (C) 1985, 1986 Bill Rozas & Jonathan Rees & Richard M. Stallman
  3.  
  4. ;; This file is part of GNU Emacs.
  5.  
  6. ;; GNU Emacs is distributed in the hope that it will be useful,
  7. ;; but WITHOUT ANY WARRANTY.  No author or distributor
  8. ;; accepts responsibility to anyone for the consequences of using it
  9. ;; or for whether it serves any particular purpose or works at all,
  10. ;; unless he says so in writing.  Refer to the GNU Emacs General Public
  11. ;; License for full details.
  12.  
  13. ;; Everyone is granted permission to copy, modify and redistribute
  14. ;; GNU Emacs, but only under the conditions described in the
  15. ;; GNU Emacs General Public License.   A copy of this license is
  16. ;; supposed to have been given to you along with GNU Emacs so you
  17. ;; can know your rights and responsibilities.  It should be in a
  18. ;; file named COPYING.  Among other things, the copyright notice
  19. ;; and this notice must be preserved on all copies.
  20.  
  21. ;; xscheme.el adapted from shell.el to scheme.  
  22. ;; tea.el adapted for T from xscheme.el by J Rees.
  23. ;; Cream and sugar by Joshua Guttman and John D. Ramsdell.
  24.  
  25. ;; Some suggestions for your .emacs file.
  26. ;; 
  27. ;;(autoload 'run-tea "tea"
  28. ;;      "Run an inferior T process."
  29. ;;      t)
  30. ;;
  31. ;; (setq auto-mode-alist
  32. ;;      (cons '("\\.t$" . scheme-mode)    ; Scheme mode for T files.
  33. ;;        auto-mode-alist))
  34. ;;
  35.  
  36. ;; A suggestion for modifying the etags program so that it knows about T.
  37. ;; You should modify the few lines that allow etags to conclude that
  38. ;; files that end with ".t" are lisp source code.  Here is the differences
  39. ;; for the current version of etags.
  40. ;;364c364
  41. ;;<   /* .l or .el or .lisp (or .cl or .clisp or .t!) implies lisp source code */
  42. ;;---
  43. ;;>   /* .l or .el or .lisp (or .cl or .clisp or ...) implies lisp source code */
  44. ;;366d365
  45. ;;<          !strcmp (cp + 1, "t") ||
  46.  
  47.  
  48. (provide 'tea)
  49. (setq scheme-mit-dialect nil)
  50. (require 'scheme)
  51. (require 'shell)
  52.  
  53. (defvar inferior-tea-mode-map nil)
  54.  
  55. (setq completion-ignored-extensions
  56.       (append '(".mo" ".mi" ".mn" ".so" ".si" ".sn")
  57.           completion-ignored-extensions))
  58.  
  59. (if inferior-tea-mode-map
  60.     nil
  61.   (setq inferior-tea-mode-map (copy-keymap shell-mode-map))
  62.   (define-key inferior-tea-mode-map "\C-c\C-a"  'quit-shell-subjob)
  63.   (define-key inferior-tea-mode-map "\C-c\C-g"  'interrupt-shell-subjob)
  64.   (define-key inferior-tea-mode-map "\C-d"    'delete-char-or-maybe-send-eof)
  65.   (define-key inferior-tea-mode-map "\C-x\C-e"    'tea-get-definition)
  66.   (define-key inferior-tea-mode-map "\e\C-x"    'tea-get-definition)
  67.   (define-key inferior-tea-mode-map "\e\C-l"    'tea-load-file)
  68.   (define-key inferior-tea-mode-map "\e\C-c"    'tea-compile-file)
  69.   (define-key inferior-tea-mode-map "\C-c\C-y"    'yank-input)
  70.   (define-key inferior-tea-mode-map "\ey"    'yank-pop-input-or-kill)
  71.   (define-key inferior-tea-mode-map "\C-m"    'tea-send-input)
  72.   (define-key inferior-tea-mode-map "\C-cl"    'tea-load-file)
  73.   (define-key inferior-tea-mode-map "\C-cc"    'tea-compile-file)
  74.   (define-key inferior-tea-mode-map "\C-co"    'tea-object-unhash)
  75.   (define-key inferior-tea-mode-map "\t"    'scheme-indent-line)
  76.   (define-key inferior-tea-mode-map "\177"    'backward-delete-char-untabify)
  77.   (define-key inferior-tea-mode-map "\e\C-q"    'scheme-indent-sexp)
  78.   (define-key inferior-tea-mode-map "\e\C-s"    'find-scheme-definition)
  79.   (define-key inferior-tea-mode-map "\e "    'fixup-whitespace))
  80.  
  81. (define-key scheme-mode-map "\C-ce"     'tea-send-definition)
  82. (define-key scheme-mode-map "\C-c\C-e"     'tea-send-definition-and-go)
  83. (define-key scheme-mode-map "\C-cc"     'tea-compile-definition)
  84. (define-key scheme-mode-map "\C-c\C-c"     'tea-compile-definition-and-go)
  85. (define-key scheme-mode-map "\C-c\C-g"     'tea-reset-process)
  86. (define-key scheme-mode-map "\C-cz"     'switch-to-tea)
  87. (define-key scheme-mode-map "\C-cd"        'tea-define-operation)
  88. (define-key scheme-mode-map "\e\^Q"     'scheme-indent-sexp)
  89. (define-key scheme-mode-map "\eg"     'balance-defuns)
  90. (define-key scheme-mode-map "\eq"     'fill-commented-paragraph)
  91. (define-key scheme-mode-map "\e\C-i"     'indent-relative)
  92. (define-key scheme-mode-map "\e\C-m"     'auto-fill-mode)
  93. (define-key scheme-mode-map "\C-x\C-s"     'balance-defuns-and-save)
  94. (define-key scheme-mode-map "\e\C-c"     'tea-eval-expression)
  95. (define-key scheme-mode-map "\e "    'fixup-whitespace)
  96.  
  97.  
  98. (defun inferior-tea-mode ()
  99.   "Major mode for interacting with an inferior T process.
  100.  
  101. The following commands are available:
  102. \\{inferior-tea-mode-map}
  103.  
  104. Entry to this mode calls the value of tea-mode-hook with no arguments,
  105. if that value is non-nil.  Likewise with the value of shell-mode-hook.
  106. tea-mode-hook is called after shell-mode-hook.
  107.  
  108. You can send text to the inferior Tea from other buffers
  109. using the commands send-region, send-string and \\[tea-send-definition].
  110.  
  111. Commands:
  112. Delete converts tabs to spaces as it moves back.
  113. Tab indents for Scheme; with argument, shifts rest
  114.  of expression rigidly with the current line.
  115. Meta-Control-Q does Tab on each line starting within following expression.
  116. Paragraphs are separated only by blank lines.  Semicolons start comments.
  117.  
  118. Return at end of buffer sends line as input.
  119. Return not at end copies rest of line to end and sends it.
  120. C-d at end of buffer sends end-of-file as input.
  121. C-d not at end or with arg deletes or kills characters.
  122. C-c C-c interrupts the shell or its current subjob if any.
  123. C-z stops, likewise.  C-\\ sends quit signal, likewise.
  124. There's other stuff too which isn't yet documented."
  125.  
  126.   (interactive)
  127.   (kill-all-local-variables)
  128.   (setq major-mode 'inferior-tea-mode)
  129.   (setq mode-name "Tea under Emacs")
  130.   (setq mode-line-process '(": %s"))
  131.   (scheme-mode-variables)
  132.   (use-local-map inferior-tea-mode-map)
  133.   (make-local-variable 'last-input-start)
  134.   (setq last-input-start (make-marker))
  135.   (make-local-variable 'last-input-end)
  136.   (setq last-input-end (make-marker))
  137.   (run-hooks 'shell-mode-hook 'scheme-mode-hook))
  138.  
  139. (defun args-to-list (string)
  140.   (let ((where (string-match "[ \t]" string)))
  141.     (cond ((null where) (list string))
  142.       ((not (= where 0))
  143.        (cons (substring string 0 where)
  144.          (args-to-list (substring string (+ 1 where)
  145.                       (length string)))))
  146.       (t (let ((pos (string-match "[^ \t]" string)))
  147.            (if (null pos)
  148.            nil
  149.          (args-to-list (substring string pos (length string)))))))))
  150.  
  151. (defvar tea-program-name "t"
  152.   "Program invoked by the tea and run-tea commands")
  153.  
  154. (defvar tea-process nil
  155.   "Process currently running tea under emacs.")
  156.  
  157. (defun tea (arg)
  158.   "Run an inferior Tea process reading a command line from the terminal."
  159.   (interactive "sExtra arguments to tea: ")
  160.   (pop-to-buffer
  161.    (apply 'make-shell (append (list "tea" tea-program-name nil)
  162.                   (args-to-list arg)
  163.                   '("-emacs"))))
  164.   (setq tea-process (get-buffer-process "*tea*"))
  165.   (inferior-tea-mode))
  166.  
  167. (defun run-tea (arg)
  168.   "Run an inferior Tea process.
  169. Input and output via buffer *tea*.
  170. With argument it asks for a command line.  "
  171.   (interactive "P")
  172.   (if arg
  173.       (call-interactively 'tea)
  174.     (pop-to-buffer (make-shell "tea" tea-program-name nil "-h" "8000000"))
  175.     (inferior-tea-mode)
  176.     (setq tea-process (get-buffer-process "*tea*"))
  177.     (message "")))
  178.  
  179. (defvar big-tea-size "24000008"
  180.   "*Size (in string form) for each heap in a big invocation of Tea.")
  181.  
  182. (defun big-tea ()
  183.   "Run an inferior Tea process with two big heaps.
  184. The meaning of \"big\" is controlled by the variable BIG-TEA-SIZE (q.v.).
  185. Input and output via buffer *tea*.  "
  186.   (interactive)
  187.   (tea (format "-h %s" big-tea-size)))
  188.  
  189. (defun balance-defuns (buff)
  190.   "Check that every defun in BUFF is balanced (current-buffer if interactive)."
  191.   (interactive (list (current-buffer)))
  192.   (set-buffer buff)
  193.   (let ((next-end (point-min)))
  194.     (condition-case ddd
  195.     (progn
  196.       (while (setq next-end (scan-sexps next-end 1)))
  197.       (if (interactive-p)
  198.           (message "All defuns balanced.")
  199.         t))
  200.       (error
  201.        (push-mark)
  202.        (goto-char next-end)
  203.        (cond ((interactive-p)
  204.           (ding)          
  205.           (message "Unbalanced defun."))
  206.          (t nil))))))
  207.  
  208. (defun balance-defuns-and-save (force)
  209.   "Call balanced-defuns on current-buffer and save it if all defuns are balanced. 
  210. Prefix arg means force save without checking for balance."
  211.   (interactive "P")
  212.   (if (or force (balance-defuns (current-buffer)))
  213.       (save-buffer)
  214.     (ding)
  215.     (message "Unbalanced defun -- buffer not saved.")))
  216.  
  217. (defun tea-send-definition ()
  218.   "Send the current definition to the Tea process made by M-x run-tea."
  219.   (interactive)
  220.   (save-excursion
  221.    (end-of-defun)
  222.    (let ((end (point)))
  223.      (beginning-of-defun)
  224.      (send-region tea-process (point) end)
  225.      (send-string tea-process "\n"))))
  226.  
  227. (defun switch-to-tea ()
  228.   "Switch to the *tea* buffer."
  229.   (interactive)
  230.   (pop-to-buffer "*tea*"))
  231.  
  232. (defun tea-eval-expression (str)
  233.   "Read a string from the minibuffer and send it to inferior tea process."
  234.   (interactive "sTea Eval: ")
  235.   (send-string tea-process (concat str " repl-wont-print\n")))
  236.  
  237. (defun tea-funcall (fn-str arg-str)
  238.   "Read a FN-STR and ARG-STR from the minibuffer and send (FN-STR ARG-STR) to
  239. inferior tea process." 
  240.   (interactive "sTea Function: \nsArguments: ")
  241.   (tea-eval-expression
  242.    (format "(%s %s)" fn-str arg-str)))
  243.  
  244. (defun tea-send-definition-and-go ()
  245.   "Send the current definition to the inferior Tea, and switch to *tea* buffer."
  246.   (interactive)
  247.   (tea-send-definition)
  248.   (switch-to-tea))
  249.  
  250. (defun tea-compile-definition ()
  251.   "Compile the current definition to the T process made by M-x run-tea."
  252.   (interactive)
  253.   (save-excursion
  254.    (end-of-defun)
  255.    (let ((end (point)))
  256.      (beginning-of-defun)
  257.      (send-string tea-process "(orbit '")
  258.      (send-region tea-process (point) end)
  259.      (send-string tea-process ")\n"))))
  260.  
  261. (defun tea-compile-definition-and-go ()
  262.   "Send and compile the current definition to the inferior T, and switch to *tea* buffer."
  263.   (interactive)
  264.   (tea-compile-definition)
  265.   (switch-to-tea))
  266.  
  267. (defun delete-char-or-maybe-send-eof (arg)
  268.   "Delete ARG characters forward, or send an EOF to T if at end of buffer."
  269.   (interactive "p")
  270.   (if (eobp)
  271.       (send-string tea-process "#.eof\n")
  272.       (delete-char arg)))
  273.  
  274. (defvar input-ring '()
  275.   "List of put-in text sequences.")
  276.  
  277. (defvar input-ring-yank-pointer '()
  278.   "The tail of the input ring whose car is the last thing yanked.")
  279.  
  280. ;;; Newline
  281.  
  282. (defun tea-send-input ()
  283.   "Send input to inferior T process."
  284.   (interactive nil)
  285.   (shell-send-input)
  286.   (save-excursion
  287.     (goto-char last-input-end)
  288.     (if (bolp) (backward-char))
  289.     (copy-region-as-input last-input-start (point))))
  290.  
  291. (defun copy-region-as-input (beg end)
  292.   "Save the region as if put in, but don't put it in."
  293.   (interactive "r")
  294.   (setq input-ring (cons (buffer-substring beg end) input-ring))
  295.   (if (> (length input-ring) kill-ring-max)
  296.       (setcdr (nthcdr (1- kill-ring-max) input-ring) nil))
  297.   (setq input-ring-yank-pointer input-ring))
  298.  
  299. (defun rotate-input-pointer (arg)
  300.   "Rotate the yanking point in input ring."
  301.   (interactive "p")
  302.   (let ((length (length input-ring)))
  303.     (if (zerop length)
  304.     (error "Input ring is empty")
  305.       (setq input-ring-yank-pointer
  306.         (nthcdr (% (+ arg (- length (length input-ring-yank-pointer)))
  307.                length)
  308.             input-ring)))))
  309.  
  310. ;;; Meta-Y
  311.  
  312. (defun yank-pop-input-or-kill (arg)
  313.   "Replace just-yanked stretch of killed-text with a different stretch.
  314. This command is allowed only immediately after a  yank , yank-input ,
  315. or itself.
  316. At such a time, the region contains a stretch of reinserted
  317. previously-killed text.  yank-pop  deletes that text and inserts in its
  318. place a different stretch of killed text.
  319.  
  320. With no argument, the previous kill is inserted.
  321. With argument n, the n'th previous kill is inserted.
  322. If n is negative, this is a more recent kill.
  323.  
  324. The sequence of kills wraps around, so that after the oldest one
  325. comes the newest one."
  326.   (interactive "*p")
  327.   (if (eq last-command 'yank)
  328.       (yank-pop arg)
  329.     (if (not (eq last-command 'yank-input))
  330.     (error ;"Previous command was not a yank"
  331.      (symbol-name last-command))
  332.       (progn
  333.     (setq this-command 'yank-input)
  334.     (let ((before (< (point) (mark))))
  335.       (delete-region (point) (mark))
  336.       (rotate-input-pointer arg)
  337.       (set-mark (point))
  338.       (insert (car input-ring-yank-pointer))
  339.       (if before (exchange-point-and-mark)))))))
  340.  
  341. ;;; Control-Meta-Y
  342.  
  343. (defun yank-input (&optional arg)
  344.   "Reinsert the last input.
  345. With just C-U as argument, same but put point in front (and mark at end).
  346. With argument n, reinsert the nth most recent input.
  347. See also the command \\[yank-pop-input-or-kill]."
  348.   (interactive "*P")
  349.   (rotate-input-pointer (if (listp arg) 0
  350.               (if (eq arg '-) -1
  351.                 (1- arg))))
  352.   (push-mark (point))
  353.   (insert (car input-ring-yank-pointer))
  354.   (if (consp arg)
  355.       (exchange-point-and-mark)))
  356.  
  357. (defun tea-object-unhash()
  358.   "Insert (object-unhash ) and poise cursor before left-paren."
  359.   (interactive)
  360.   (insert-string "(object-unhash )")
  361.   (backward-char 1))
  362.  
  363. (defun tea-load-file (file-name)
  364.   "Load a Tea file into the inferior Tea process."
  365.   (interactive
  366.    (list
  367.     (expand-file-name
  368.      (read-file-name "Load Tea file: " default-directory "" t))))
  369.   (send-string tea-process (concat "(load \""
  370.                    file-name
  371.                    "\"\)\n"))
  372.   (switch-to-tea))
  373.  
  374. (defun tea-compile-file (file-name)
  375.   "Compile a Tea file in the inferior Tea process."
  376.   (interactive "fCompile Tea file: ")        
  377.   (send-string tea-process (concat "(compile-file \""
  378.                  file-name
  379.                  "\"\)\n"))
  380.   (switch-to-tea))
  381.  
  382.  
  383. (defun tea-chdir (dir)
  384.   "Switch tea process to new current-directory."
  385.   (interactive "DChange to directory: ")
  386.   (send-string tea-process (concat "((*value t-implementation-env 'unix-chdir) \""
  387.                  (substring (expand-file-name dir) 0 -1)
  388.                  "\"\)\n"))
  389.   (switch-to-tea)
  390.   (setq default-directory dir))
  391.  
  392. (defun tea-grep (target)
  393.   "run grep asynchronously, ignoring case, searching for TARGET throughout the files *.t" 
  394.   (interactive "sTarget: ")
  395.   (grep (format "-i %s *.t" target)))
  396.  
  397.  
  398. (put 'labels 'scheme-indent-hook 1)
  399. (put 'xcase 'scheme-indent-hook 1)
  400. (put 'select 'scheme-indent-hook 1)
  401. (put 'xselect 'scheme-indent-hook 1)
  402. (put 'typecase 'scheme-indent-hook 1)
  403. (put 'destructure 'scheme-indent-hook 1)
  404. (put 'destructure* 'scheme-indent-hook 1)
  405. (put 'with-open-ports 'scheme-indent-hook 1)
  406. (put 'bind 'scheme-indent-hook 1)
  407. (put 'bind* 'scheme-indent-hook 1)
  408. (put 'iterate 'scheme-indent-hook 2)
  409. (put 'receive 'scheme-indent-hook 1)
  410. (put 'block 'scheme-indent-hook 0)
  411. (put 'catch 'scheme-indent-hook 1)
  412. (put 'object 'scheme-indent-hook 1)
  413. (put 'operation 'scheme-indent-hook 1)
  414. (put 'join 'scheme-indent-hook 0)
  415.  
  416.  
  417. (modify-syntax-entry ?[ "(]" scheme-mode-syntax-table)
  418. (modify-syntax-entry ?] ")[" scheme-mode-syntax-table)
  419. (modify-syntax-entry ?{ "(}" scheme-mode-syntax-table)
  420. (modify-syntax-entry ?} "){" scheme-mode-syntax-table)
  421.